home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 11 / CU Amiga Magazine's Super CD-ROM 11 (1997)(EMAP Images)(GB)(Track 1 of 3)[!][issue 1997-06].iso / cucd / programming / oberonv4 / source / system / asciicoder.mod (.txt) < prev    next >
Oberon Text  |  1996-08-11  |  11KB  |  220 lines
  1. Syntax10.Scn.Fnt
  2. Syntax10i.Scn.Fnt
  3. Syntax10b.Scn.Fnt
  4. ParcElems
  5. Alloc
  6. MODULE AsciiCoder;    (* Copyright (c) ETH Z
  7. rich, 1989-95 / ww, shml 10.9.93 *)
  8.     See, and update if necessary the history at the bottom of the file.
  9. (* original by Wolfgang Weck, compression due to Stefan Ludwig *)
  10. IMPORT Texts, Files, Oberon, Viewers, MenuViewers, TextFrames, Display;
  11. CONST
  12.     Base = 48; StopBase = 35;
  13.     N = 16384;
  14.     Menu = "^Edit.Menu.Text  System.Close  System.Copy  System.Grow  Edit.Search  Edit.Replace  Edit.Parcs  Edit.Store  EditTools.StoreAscii  ";
  15.     NameList = POINTER TO NameDesc;
  16.     NameDesc = RECORD
  17.         next: NameList;
  18.         name: POINTER TO ARRAY 64 OF CHAR
  19.     END;
  20.     w: Texts.Writer;
  21.     table: ARRAY N OF CHAR;    (* hash table for compression *)
  22. PROCEDURE Compress*(src, dest: Files.File);    (* due to Stefan Ludwig *)
  23.         from, to: Files.Rider;
  24.         hash, byte, bit, i: LONGINT;
  25.         ch: CHAR;
  26. BEGIN
  27.     i := 0; REPEAT table[i] := 0X; INC(i) UNTIL i = N;
  28.     Files.Set(from, src, 0); Files.Set(to, dest, 0);
  29.     i := Files.Length(src); Files.WriteNum(to, i);
  30.     hash := 0; bit := 0; byte := 0;
  31.     REPEAT
  32.         Files.Read(from, ch);
  33.         IF table[hash] = ch THEN    (* 0 bit for correct prediction *)
  34.             INC(bit); IF bit = 8 THEN Files.Write(to, CHR(byte)); byte := 0; bit := 0 END
  35.         ELSE    (* Incorrect prediction -> 1'xxxx'xxxx bits where x = ch[0..7] *)
  36.             table[hash] := ch; INC(byte, ASH(1, bit)); INC(bit);
  37.             IF bit = 8 THEN Files.Write(to, CHR(byte)); Files.Write(to, ch);  byte := 0; bit := 0
  38.             ELSE Files.Write(to, CHR(byte+ASH(ORD(ch), bit) MOD 256)); byte := ASH(ORD(ch), bit) DIV 256
  39.             END
  40.         END;
  41.         DEC(i); hash := (16*hash+ORD(ch)) MOD N    (* hash value *)
  42.     UNTIL i = 0;
  43.     IF bit # 0 THEN Files.Write(to, CHR(byte)) END    (* write last byte *)
  44. END Compress;
  45. PROCEDURE Expand*(src, dest: Files.File);    (* due to Stefan Ludwig *)
  46.         from, to: Files.Rider;
  47.         hash, val, byte, bit, i: LONGINT;
  48.         ch: CHAR;
  49. BEGIN
  50.     i := 0; REPEAT table[i] := 0X; INC(i) UNTIL i = N;
  51.     Files.Set(from, src, 0); Files.Set(to, dest, 0);
  52.     Files.ReadNum(from, i); Files.Read(from, ch); val := ORD(ch); bit := 0; hash := 0;
  53.     REPEAT
  54.         INC(bit);
  55.         IF ODD(val) THEN    (* Incorrect prediction -> 1'xxxx'xxxx *)
  56.             Files.Read(from, ch);
  57.             IF bit = 8 THEN byte := ORD(ch)
  58.             ELSE byte := val DIV 2 + ASH(ORD(ch), 8-bit) MOD 256; val := ASH(ORD(ch), -bit)
  59.             END;
  60.             table[hash] := CHR(byte)
  61.         ELSE byte := ORD(table[hash]); val := val DIV 2    (* correct prediction *)
  62.         END;
  63.         hash := (16*hash+byte) MOD N; Files.Write(to, CHR(byte)); DEC(i);
  64.         IF bit = 8 THEN Files.Read(from, ch); val := ORD(ch); bit := 0 END
  65.     UNTIL i = 0
  66. END Expand;
  67. PROCEDURE Code*(from: Files.File; to: Texts.Text);
  68.     VAR r: Files.Rider; ch: CHAR; byte, rest, div, factor, packs: INTEGER;
  69. BEGIN Files.Set(r, from, 0); Files.Read(r, ch); byte := ORD(ch); rest := 0; div := 64; factor  := 1; packs := 0;
  70.     WHILE ~r.eof DO Texts.Write(w, CHR(Base + rest + (byte MOD div) * factor)); rest := byte DIV div;
  71.         IF div = 4 THEN Texts.Write(w, CHR(Base + rest));
  72.             rest := 0; div := 64; factor  := 1; INC(packs);
  73.             IF packs = 19 THEN Texts.WriteLn(w); packs := 0 END
  74.         ELSE factor := factor * 4; div := div DIV 4
  75.         END;
  76.         Files.Read(r, ch); byte := ORD(ch)
  77.     END;
  78.     IF div = 64 THEN Texts.Write(w, CHR(StopBase))
  79.     ELSIF div = 16 THEN Texts.Write(w, CHR(Base + rest)); Texts.Write(w, CHR(StopBase + 1))
  80.     ELSIF div = 4 THEN Texts.Write(w, CHR(Base + rest)); Texts.Write(w, CHR(StopBase + 2))
  81.     END;
  82.     Texts.WriteLn(w); Texts.Append(to, w.buf)
  83. END Code;
  84. PROCEDURE Decode*(from: Texts.Text; VAR pos: LONGINT; to: Files.File; VAR ok: BOOLEAN);
  85.     VAR r: Texts.Reader; w: Files.Rider; rest, div, factor, byte: INTEGER; ch: CHAR;
  86. BEGIN
  87.     Texts.OpenReader(r, from, pos);
  88.     Files.Set(w, to, 0);
  89.     factor := 1;
  90.     div := 256;
  91.     REPEAT Texts.Read(r, ch) UNTIL (ch > " ") OR r.eot;
  92.     WHILE ~r.eot & (ch >= CHR(Base)) & (ch < CHR(Base + 64)) DO byte := ORD(ch) - Base;
  93.         IF factor # 1 THEN
  94.             Files.Write(w, CHR(rest + (byte MOD div) * factor));
  95.             rest := byte DIV div; div := div * 4; factor := factor DIV 4
  96.         ELSE
  97.             rest := byte; div := 4; factor := 64
  98.         END;
  99.         REPEAT Texts.Read(r, ch) UNTIL (ch > " ") OR r.eot
  100.     END;
  101.     byte := ORD(ch) - StopBase;
  102.     ok := (byte = 0) & (div = 256) OR (byte = 1) & (div = 16) OR (byte = 2) & (div = 64) & (rest = 0);
  103.     pos := Texts.Pos(r)
  104. END Decode;
  105. PROCEDURE OpenViewer(name: ARRAY OF CHAR; text: Texts.Text);
  106.     VAR dummyViewer: Viewers.Viewer; f: Display.Frame; x, y: INTEGER;
  107. BEGIN Oberon.AllocateUserViewer(Oberon.Par.vwr.X, x, y);
  108.     f := TextFrames.NewText(text, 0);
  109.     dummyViewer := MenuViewers.New(TextFrames.NewMenu(name, Menu), f, TextFrames.menuH, x, y)
  110. END OpenViewer;
  111. PROCEDURE ReadFileNames(t: Texts.Text; beg, end: LONGINT; VAR names: NameList; VAR pos: LONGINT);
  112.     VAR last, n: NameList; s: Texts.Scanner;
  113. BEGIN NEW(names); last := names; Texts.OpenScanner(s, t, beg); pos := beg; Texts.Scan(s);
  114.     WHILE (pos < end) & ((s.class = Texts.String) OR (s.class = Texts.Name)) DO NEW(n); last.next := n; last := n;
  115.         NEW(n.name); COPY(s.s, n.name^);
  116.         pos := Texts.Pos(s); Texts.Scan(s)
  117.     END;
  118.     last.next := NIL; names := names.next; pos := Texts.Pos(s)
  119. END ReadFileNames;
  120. PROCEDURE CodeFiles*;
  121.     VAR pos, beg, end, time: LONGINT; compress: BOOLEAN; names, n: NameList;
  122.         f, f1: Files.File; text: Texts.Text; s: Texts.Scanner; 
  123. BEGIN pos := Oberon.Par.pos; compress := FALSE;
  124.     Texts.OpenScanner(s, Oberon.Par.text, pos); Texts.Scan(s);
  125.     IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; pos := Texts.Pos(s); Texts.Scan(s) END;
  126.     IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "^") THEN Oberon.GetSelection(text, beg, end, time);
  127.         IF time >= 0 THEN ReadFileNames(text, beg, end, names, time) ELSE names := NIL END
  128.     ELSE ReadFileNames(Oberon.Par.text, pos, Oberon.Par.text.len, names, time)
  129.     END;
  130.     IF names # NIL THEN n := names; text := TextFrames.Text("");
  131.         Texts.WriteString(w, "AsciiCoder.CodeFiles"); Texts.WriteLn(w);
  132.         REPEAT f := Files.Old(n.name^); Texts.WriteString(w, n.name^);
  133.             IF f = NIL THEN Texts.WriteString(w, " not found"); n.name := NIL
  134.             ELSE Texts.WriteString(w, " coding"); Texts.Append(Oberon.Log, w.buf);
  135.                 IF compress THEN f1 := Files.New(""); Compress(f, f1); f := f1 END;
  136.                 Code(f, text)
  137.             END;
  138.             Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf); n := n.next
  139.         UNTIL n = NIL;
  140.         Texts.WriteString(w,"AsciiCoder.DecodeFiles ");
  141.         IF compress THEN Texts.WriteString(w, "% ") END;
  142.         REPEAT
  143.             IF names.name # NIL THEN Texts.WriteString(w, names.name^); Texts.Write(w, " ") END;
  144.             names := names.next
  145.         UNTIL names = NIL;
  146.         Texts.Write(w, "~"); Texts.WriteLn(w); Texts.WriteLn(w); Texts.Insert(text, 0, w.buf);
  147.         Texts.WriteInt(w, text.len, 0); Texts.WriteString(w, " characters"); Texts.WriteLn(w);
  148.         Texts.Append(Oberon.Log, w.buf);
  149.         OpenViewer("AsciiCoder.CodeFiles", text)
  150. END CodeFiles;
  151. PROCEDURE DecodeFiles*;
  152.     VAR pos, beg, end, time: LONGINT; i, res: INTEGER; ch: CHAR; ok, compress: BOOLEAN;
  153.         f, f1: Files.File; text: Texts.Text; s: Texts.Scanner; names: NameList; bakname: ARRAY 256 OF CHAR;
  154. BEGIN text := Oberon.Par.text; pos := Oberon.Par.pos; compress := FALSE;
  155.     Texts.OpenScanner(s, text, pos); Texts.Scan(s);
  156.     IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; pos := Texts.Pos(s); Texts.Scan(s) END;
  157.     IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "@") THEN Oberon.GetSelection(text, beg, end, time);
  158.         IF time >= 0 THEN ReadFileNames(text, beg, end, names, pos) ELSE names := NIL END
  159.     ELSE ReadFileNames(text, pos, text.len, names, pos)
  160.     END;
  161.     Texts.WriteString(w, "AsciiCoder.DecodeFiles"); Texts.WriteLn(w); ok := TRUE;
  162.     WHILE (names # NIL) & ok DO f := Files.New(names.name^);
  163.         Texts.WriteString(w, names.name^); Texts.WriteString(w, " decoding"); Texts.Append(Oberon.Log, w.buf);
  164.         i := 0; ch := names.name[0];
  165.         WHILE ch # 0X DO bakname[i] := ch; INC(i); ch := names.name[i] END;
  166.         bakname[i] := "."; bakname[i + 1] := "B"; bakname[i + 2] := "a"; bakname[i + 3] := "k"; bakname[i + 4] := 0X;
  167.         Files.Rename(names.name^, bakname, res); Decode(text, pos, f, ok);
  168.         IF ok THEN
  169.             IF compress THEN f1 := Files.New(names.name^); Expand(f, f1); f := f1 END;
  170.             Files.Register(f)
  171.         ELSE Texts.WriteString(w, " error.")
  172.         END;
  173.         Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf); names := names.next
  174. END DecodeFiles;
  175. PROCEDURE CodeText*;
  176.     VAR beg, end, time: LONGINT; compress: BOOLEAN;
  177.         v: Viewers.Viewer; f, f1: Files.File; r: Files.Rider; t, text: Texts.Text; s: Texts.Scanner;
  178. BEGIN compress := FALSE;
  179.     Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  180.     IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; Texts.Scan(s) END;
  181.     IF (s.line = 0) & (s.class = Texts.Char) THEN t := NIL;
  182.         IF s.c = "*" THEN v := Oberon.MarkedViewer();
  183.             IF (v IS MenuViewers.Viewer) & (v.dsc.next IS TextFrames.Frame) THEN
  184.                 t := v.dsc.next(TextFrames.Frame).text
  185.             END
  186.         ELSIF s.c = "@" THEN Oberon.GetSelection(text, beg, end, time);
  187.             IF time >= 0 THEN t := TextFrames.Text(""); Texts.Save(text, beg, end, w.buf); Texts.Append(t, w.buf) END
  188.         END;
  189.         IF t # NIL THEN f := Files.New(""); Files.Set(r, f, 0); Files.Write(r, 0F0X); Files.Write(r, 01X); Texts.Store(r, t);
  190.             text := TextFrames.Text("");
  191.             Texts.WriteString(w, "AsciiCoder.DecodeText");
  192.             IF compress THEN Texts.WriteString(w, " %") END;
  193.             Texts.WriteLn(w); Texts.WriteLn(w); Texts.Append(text, w.buf);
  194.             IF compress THEN f1 := Files.New(""); Compress(f, f1); f := f1 END;
  195.             Code(f, text); OpenViewer("AsciiCoder.CodeText", text);
  196.             Texts.WriteString(w, "AsciiCoder.CodeText "); Texts.WriteInt(w, text.len, 0);
  197.             Texts.WriteString(w, " characters"); Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
  198.         END
  199. END CodeText;
  200. PROCEDURE DecodeText*;
  201.     VAR pos, beg, end, time: LONGINT; ok, compress: BOOLEAN;
  202.         f, f1: Files.File; r: Files.Rider; text: Texts.Text; s: Texts.Scanner;
  203. BEGIN compress := FALSE; pos := Oberon.Par.pos; f := Files.New("");
  204.     Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  205.     IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "%") THEN compress := TRUE; pos := Texts.Pos(s); Texts.Scan(s) END;
  206.     IF (s.line = 0) & (s.class = Texts.Char)  & (s.c = "@") THEN Oberon.GetSelection(text, beg, end, time);
  207.         IF time >= 0 THEN Decode(text, beg, f, ok) ELSE ok := FALSE END
  208.     ELSE Decode(Oberon.Par.text, pos, f, ok)
  209.     END;
  210.     IF ok THEN
  211.         IF compress THEN f1 := Files.New(""); Expand(f, f1); f := f1 END;
  212.         text := TextFrames.Text(""); Files.Set(r, f, 2); Texts.Load(r, text);
  213.         OpenViewer("AsciiCoder.DecodeText", text)
  214.     ELSE Texts.WriteString(w, "AsciiCoder.DecodeText error."); Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
  215. END DecodeText;
  216. BEGIN Texts.OpenWriter(w)
  217. END AsciiCoder.
  218. Date    Author    Modification
  219. 1996-08-01    claudio@dial.eunet.ch    First unified version.
  220.